home *** CD-ROM | disk | FTP | other *** search
/ Mac Mania 2 / MacMania 2.toast / Demo's / Tools&Utilities / Programming / PowerLisp 1.1 / Library / structures.lisp < prev   
Encoding:
Text File  |  1994-03-25  |  4.5 KB  |  181 lines  |  [TEXT/ROSA]
  1. ;;
  2. ;;        Copyright © 1994 Roger Corman.  All rights reserved.
  3. ;;
  4.  
  5. ;;        PowerLisp Structure facility.
  6.  
  7. (provide :structures)
  8. (in-package :common-lisp)
  9.  
  10. (defmacro defstruct (name-and-options &rest doc-and-slots)
  11.     (let (    name 
  12.             options 
  13.             doc-string 
  14.             slot-descriptors 
  15.             struct-template
  16.             constructor-name
  17.             (conc-name nil)
  18.             copier-name
  19.             predicate-name
  20.             accessor-name
  21.             (print-function nil)
  22.             setter-name
  23.             (slot-number 0)
  24.             (expressions nil)) 
  25.             
  26.         (if (symbolp name-and-options)
  27.             (setq name name-and-options)
  28.             (progn
  29.                 (if (or (not (consp name-and-options)) (not (symbolp (car name-and-options))))
  30.                     (error "Invalid syntax for defstruct name: ~A" name-and-options))
  31.                 (setq name (car name-and-options))
  32.                 (setq options (cdr name-and-options))))
  33.  
  34.         (setq conc-name (concatenate 'string (symbol-name name) "-"))
  35.  
  36.         (dolist (opt options)
  37.             (cond
  38.                 ((keywordp opt))
  39.                 ((and (listp opt) (keywordp (car opt)))
  40.                  (case (car opt)
  41.                     (:conc-name 
  42.                         (if (cdr opt)
  43.                             (setq conc-name 
  44.                                     (if (cadr opt) 
  45.                                         (symbol-name (cadr opt))
  46.                                         ""))))
  47.                     (:constructor (if (cdr opt) (setq constructor-name (cadr opt))))
  48.                     (:copier (if (cdr opt) (setq copier-name (cadr opt))))
  49.                     (:predicate (if (cdr opt) (setq predicate-name (cadr opt))))
  50.                     (:include (error "defstruct option not implemented: ~A~%" (car opt)))
  51.                     (:print-function (if (cdr opt) (setq print-function (cadr opt))))
  52.                     (:type (error "defstruct option not implemented: ~A~%" (car opt)))
  53.                     (:named t)
  54.                     (:initial-offset t)
  55.                     (otherwise (error "Unknown defstruct option: ~A~%" (car opt)))))
  56.                 (t (error "Invalid defstruct option: ~A~%" opt))))    
  57.  
  58.         (if (stringp (car doc-and-slots))
  59.             (progn
  60.                 (setq doc-string (car doc-and-slots))
  61.                 (setq slot-descriptors (cdr doc-and-slots)))
  62.             (setq slot-descriptors doc-and-slots))
  63.         
  64.         ;; add the doc string with structure attribute    
  65.         (if doc-string
  66.             (push 
  67.                 `(setf (documentation ',name 'structure) ,doc-string) 
  68.                 expressions))
  69.         
  70.         ;; process slot options
  71.         (push name struct-template)
  72.         
  73.         (dolist (opt slot-descriptors)
  74.             (cond
  75.                 ((symbolp opt)  
  76.                     (push (intern (symbol-name opt) :keyword) struct-template)
  77.                     (push nil struct-template))
  78.                 ((consp opt)
  79.                     (let ((sym (car opt)))
  80.                         (if (not (symbolp sym))
  81.                             (error "Invalid slot descriptor: ~A~%" sym))                    
  82.                         (push (intern (symbol-name sym) :keyword) struct-template)
  83.                         (push (cadr opt) struct-template)))
  84.                 (t (error "Invalid slot option: ~A~%" opt))))
  85.  
  86.         ;; install template        
  87.         (push
  88.             `(setf (get ',name :struct-template) 
  89.                 (apply #'define-struct-template ',(reverse struct-template)))
  90.             expressions)
  91.  
  92.         ;; install print function        
  93.         (if print-function
  94.             (push
  95.                 `(setf (get ',name :struct-print) 
  96.                     (function ,print-function))
  97.                 expressions))
  98.             
  99.         ;; install constructor function            
  100.         (setq constructor-name
  101.             (if constructor-name 
  102.                 (intern (symbol-name constructor-name))
  103.                 (intern (concatenate 'string "MAKE-" (symbol-name name)))))
  104.             
  105.         (push
  106.             `(setf (symbol-function ',constructor-name)
  107.                 #'(lambda (&rest args) 
  108.                     (_make-struct (get ',name :struct-template) args)))
  109.             expressions)
  110.         
  111.         ;; install copier function            
  112.         (setq copier-name
  113.             (if copier-name 
  114.                 (intern (symbol-name copier-name))
  115.                 (intern (concatenate 'string "COPY-" (symbol-name name)))))
  116.             
  117.         (push
  118.             `(setf (symbol-function ',copier-name)
  119.                 #'(lambda (arg) (clone-struct arg)))
  120.             expressions)
  121.         
  122.         ;; install predicate function            
  123.         (setq predicate-name
  124.             (if predicate-name 
  125.                 (intern (symbol-name predicate-name))
  126.                 (intern (concatenate 'string (symbol-name name) "-P"))))
  127.             
  128.         (push
  129.             `(setf (symbol-function ',predicate-name)
  130.                 #'(lambda (arg) (_check-struct-type arg ',name)))
  131.             expressions)
  132.         
  133.         ;; install accessor functions
  134.         
  135.         (dolist (slot slot-descriptors)
  136.         
  137.             ;; install accessor function for this slot            
  138.             (setq accessor-name 
  139.                 (intern 
  140.                     (concatenate 'string conc-name 
  141.                         (symbol-name (if (symbolp slot) slot (car slot))))))
  142.             
  143.             (push
  144.                 `(setf (symbol-function ',accessor-name)
  145.                     #'(lambda (arg) (get-struct-field arg ,slot-number)))
  146.                 expressions)
  147.  
  148.             (setq setter-name (intern (concatenate 'string "%SET-" (symbol-name accessor-name))))        
  149.             
  150.             (push
  151.                 `(setf (symbol-function ',setter-name)
  152.                     #'(lambda (arg value) (set-struct-field arg ,slot-number value)))
  153.                 expressions)
  154.             (push `(defsetf ,accessor-name ,setter-name) expressions)    
  155.             (setq slot-number (1+ slot-number)))
  156.  
  157.         (push `',name expressions)    
  158.         (cons 'progn (reverse expressions))))
  159.  
  160.  
  161.  
  162.  
  163.  
  164.  
  165.  
  166.  
  167.  
  168.  
  169.  
  170.  
  171.  
  172.  
  173.  
  174.  
  175.  
  176.  
  177.  
  178.  
  179.  
  180.  
  181.